#!/usr/bin/perl
# 
#  gandalf - weighted greylisting based on information we can obtain
#            before DATA stage of the SMTP process.
# 
#  Copyright (C) 2007 Martin Zobel-Helas
#  Copyright (C) 2007 Don Armstrong <don@donarmstrong.com>
#
#  Based on ideas from:
#	* Robert Felber	    Author of: policyd-weight
#	  <r.felber@ek-muc.de>
#
#	* David Schweikert    Author of: postgrey
#	  <dws@ee.ethz.ch>
#
#	* Christian Bricart   Author of the original AMaViS Shell script now doing Perl;-)
#	  <christian@bricart.de>
#
#	* The postfix greylist.pl, shiped in postfix/examples
# 
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2, or (at your option)
#  any later version.
# 
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
# 
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software Foundation,
#  Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA.
# 
# TODO: signal handling
#

use warnings;
use strict;

use Getopt::Long;
use Pod::Usage;

=head1 NAME

gandalf - weighted greylisting based on information we can obtain
          before DATA stage of the SMTP process.

=head1 SYNOPSIS

 gandalf [options]

 Options:
  --daemonize, -d daemonize (default)
  --pidfile location of pidfile (/var/run/gandalf/gandalf.pid)
  --socket location of socket (/var/run/gandalf/gandalf.sock)
  --host host/port to use for tcp sockets
  --max-connections maximum connections to allow per socket
  --pidlock lockfile for pid (pidfile.lock)
  --verbose, -v verbosity level (Default 0)
  --debug, -D debugging level (Default 0)
  --help, -h display this help
  --man, -m display manual

=head1 OPTIONS

=over

=item B<--daemonize,-d>

Whether to daemonize (default). --no-daemonize to disable

=item B<--pidfile>

Pidfile location; defaults to /var/run/gandalf/gandalf.pid

=item B<--socket>

Socket location; defaults to /var/run/gandalf/gandalf.sock if no other
socket or host is specified.

=item B<--host>

Host to listen on; specified as hostname:portnum (or ip:portnum).

=item B<--max-connections>

Maximum connections to allow to tcp ports; defaults to 30.

=item B<--pidlock>

Lockfile for the pidfile; defaults to the location of the pidfile with
.lock appended.

=item B<--debug, -D>

Debug verbosity. (Default 0)

=item B<--help, -h>

Display brief useage information.

=item B<--man, -m>

Display this manual.

=back

=head1 EXAMPLES


=cut


use Fcntl qw(:flock);
#use BerkeleyDB;
use Digest::MD5 qw(md5 md5_hex);
use IO::Socket::INET;
use IO::Socket::UNIX;
use IO::Select;
use IO::File;
use Net::DNS;
use POSIX qw(strftime setsid);
use Sys::Syslog qw(:DEFAULT setlogsock);
use Params::Validate qw(:types validate_with);

use Time::HiRes qw(sleep);

use List::Util qw(first);

use constant {BAD => 0, GOOD => 1};


use vars qw($DEBUG);

my %options = (debug           => 0,
	       help            => 0,
	       man             => 0,
	       verbose         => 0,
	       daemonize       => 1,
	       pidfile         => '/var/run/gandalf/gandalf.pid',
	       pidlock         => undef,
	       socket          => [],
	       host            => [],
	       max_connections => 30,
	       );

GetOptions(\%options,'debug|D+','help|h|?','man|m',
	   'verbose|v+',
	   'daemonize|daemon|d!',
	   'pidfile=s',
	   'pidlock=s',
	   'max_connections|max-connections=s',
	   'host=s@',
	   'socket=s@',
	  );
if (not defined $options{pidlock}) {
     $options{pidlock} = $options{pidfile}.'.lock';
}

if (not @{$options{socket}} and
    not @{$options{host}}) {
     push @{$options{socket}},'/var/run/gandalf/gandalf.sock';
}

pod2usage() if $options{help};
pod2usage({verbose=>2}) if $options{man};

$DEBUG = $options{debug};

if ($options{daemonize}) {
     my $pidfh;
     if ($options{pidfile}) {
	  my $pidlock = new IO::File->new($options{pidlock},'w') or
	       die "Unable to open pidlock $options{pidlock} for writing: $!";
	  flock($pidlock,LOCK_EX) or
	       die "Unable to lock pidlock $options{pidlock}: $!";
	  if (-e $options{pidfile}) {
	       $pidfh = IO::File->new($options{pidfile},'r') or
		    die "Unable to open pidfile $options{pidfile} for reading: $!";
	       local $/;
	       my $pid = <$pidfh>;
	       ($pid) = $pid =~ /(\d+)/;
	       if (defined $pid and kill(0,$pid)) {
		    print STDERR "Copy of $0 running with pid $pid (pidfile: $options{pidfile})";
		    unlink($options{pidlock});
		    undef $pidlock;
		    exit 1;
	       }
	       close $pidfh;
	       unlink ($options{pidfile}) or
		    die "Unable to unlink stale pidfile $options{pidfile}: $!";
	  }
	  $pidfh = IO::File->new($options{pidfile},'w') or
	       die "Unable to open $options{pidfile} for writing: $!";
     }
     # daemonize
     chdir '/' or die "Can't chdir to /: $!";
     open STDIN, '/dev/null' or die "Can't read /dev/null: $!";
     open STDOUT, '>/dev/null'
	  or die "Can't write to /dev/null: $!";
     defined(my $pid = fork) or die "Can't fork: $!";
     exit if $pid;
     setsid or die "Can't start a new session: $!";
     if (defined $pidfh) {
	  print {$pidfh} $$ or die "Unable to write to pidfile $options{pidfile}: $!";
	  close $pidfh or die "Unable to close pidfile $options{pidfile}: $!";
     }
     open STDERR, '>&STDOUT' or die "Can't dup stdout: $!";
}


my $tcp_port		= 10025;
my $bind_address	= "localhost";
my $max_connection	= "40";

# my $DEFAULT_RESPONSE	= 'DUNNO default';
my $syslog_socktype	= "unix"; # inet, unix, stream, console
my $syslog_facility	= "mail";
my $syslog_options	= "pid";
my $syslog_priority	= "info";
my $syslog_ident	= "postfix/greylist-weight";
my $delaytime		= "30";
my %db;
my $dbname		= "greylisting.db";
my $dbdir		= "/tmp/";
my $verbose		= 1;
my $cutoff		= "4";

# a set of RBL servers, with name, scores, output text, and type

# supported tests
my @tests = (
	     HELO_REV  => {function => 'test_helo_rev',
			   func_args => [],
			   good      => '',
			  },
	     DYN_NJABL => {function  => 'dns_rbl',
			   func_args => [dns => 'dynablock.njabl.org',
					 dyn => 1,
					 attr => 'client_address',
					],
			   good      => 0,
			   bad       => 3.25,
			  },
	     SBL_XBL_SPAMHAUS => {function  => 'dns_rbl',
				  func_args => [dns => 'sbl-xbl.spamhaus.org',
						attr => 'client_address',
					       ],
				  bad  => 4.35,
				  good => -1.5,
				 },
	     SPAMCOP => {function  => 'dns_rbl',
			 func_args => [dns => 'bl.spamcop.net',
				       attr => 'client_address',
				      ],
			 bad  => 3.75,
			 good => -1.5,
			},
	     BL_NJABL => {function  => 'dns_rbl',
			  func_args => [dns => 'dnsbl.njabl.org',
					attr => 'client_address',
				       ],
			  bad  => 4.25,
			  good => -1.5,
			 },
	     DSBL_ORG => {function  => 'dns_rbl',
			  func_args => [dns => 'list.dsbl.org',
					dyn => 1,
					attr => 'client_address',
				       ],
			  bad  => 4.35,
			  good => 0,
			 },
	     IX_MANITU => {function  => 'dns_rbl',
			   func_args => [dns => 'ix.dnsbl.manitu.net',
					 attr => 'client_address',
					],
			   bad  => 4.35,
			   good => 0,
			  },
	     SURBL     => {function  => 'dns_rbl',
			   func_args => [dns => 'multi.surbl.org',
					 attr => 'sender',
					],
			   good      => -0.6,
			   bad       => 4,
			  },
	     AHBL      => {function  => 'dns_rbl',
			   func_args => [dns => 'rhsbl.ahbl.org',
					 attr => 'sender',
					],
			   bad  => 1.8,
			   good => -0.5,
			  },
	     DSN_RFCI => {function   => 'dns_rbl',
			  func_args => [dns => 'dsn.rfc-ignorant.org',
					attr => 'sender',
				       ],
			  bad  => 3.2,
			  good => -1.2,
			 },
	     PM_RFCI => {function   => 'dns_rbl',
			 func_args => [dns => 'postmaster.rfc-ignorant.org',
				       attr => 'sender',
				      ],
			 bad  => 0.1,
			 good => -0.3,
			},
	     ABUSE_RFCI => {function   => 'dns_rbl',
			    func_args => [dns => 'abuse.rfc-ignorant.org',
					  attr => 'sender',
					 ],
			    bad  => 0.1,
			    good => -0.2,
			   },
	    );
my %tests = @tests;
# we want @tests[0,2,4,6,...] etc.
my @tests_order = @tests[map {$_ * 2} 0..(@tests-2)/2];

my $client_seems_dialup = 0;

# scores for checks, WARNING: they may manipulate eachother
# or be factors for other scores.
#                                       Bad score, Good Score
my @client_ip_eq_helo_score          = (1.5,       -1.25 );
my @helo_numeric_score               = (1.5,        0    );
my @from_match_regex_helo            = (1,         -2    );
my @helo_seems_dialup                = (-0.2,       0    );
my @client_seems_dialup_score        = (3.75,       0    );
my @from_anon                        = (1.17,       0    );
my @from_spf                         = (1.2,        0    );
# my @bogus_mx_score                   = (2.1,        0    );
# my @random_sender_score              = (0.25,       0    );
# my @rhsbl_penalty_score              = (3.1,        0    );
# my @helo_score                       = (1.5,       -2    );
# my @helo_from_mx_eq_ip_score         = (1.5,       -3.1  );
# my @from_match_regex_unverified_helo = (1.6,       -1.5  );
# my @from_match_regex_failed_helo     = (2.5,        0    );
# my @failed_helo_seems_dialup         = (2,          0    );
# my @helo_ip_in_client_subnet         = (0,         -1.2  );
# my @helo_ip_in_cl16_subnet           = (0,         -0.41 );
# my @from_multiparted                 = (1.09,       0    );


# reverts the oder of octects of the IP address 
# 12.34.56.78 -> 78.56.34.12
# needed for left hand RBL lookups.
sub reverse_ips {
    my $ip = shift();
    return join (".", reverse (split(/\./, $ip)));
}

sub subnet_ips {
    my $ip = shift();
    $ip =~ /((?:\d+\.){2}\d+)/;
    return $1;
}

# dns_rbl
#
our $resolver;
our %dns_queries;
sub resolve_dns{
     my %param = validate_with(params => \@_,
			       spec => {query => SCALAR,
					noblock  => {type => BOOLEAN,
						     default => 1,
						    },
				       },
			      );
     if (not defined $resolver) {
	  $resolver = Net::DNS::Resolver->new() or
	       die "Unable to create new resolver";
     }
     my $query = $param{query};
     my $query_obj;
     # see if we've got an open socket for the query or results for this query
     if (defined $dns_queries{$query} and
	 (defined $dns_queries{$query}{socket} or
	  defined $dns_queries{$query}{results}
	 )
	){
	  $query_obj = $dns_queries{$query};
     }
     else {
	  my $socket = $resolver->bgsend($query) or
	       warn "Unable to do dns query for '$query'" and
		    return undef;
	  $query_obj = {socket => $socket,
			results => undef,
			waiting => 0,
		       };
     }
     if (not defined $query_obj->{results}) {
	  if (defined $query_obj->{socket}) {
	       # not a non-blocking run, block here for 20s for the result to return
	       if (not $param{noblock}) {
		    my $loop = 40;
		    while (not $resolver->bgisready($query_obj->{socket})) {
			 last if $loop <= 0;
			 $loop--;
			 sleep 0.5;
		    }
	       }
	       if ($resolver->bgisready($query_obj->{socket})) {
		    $query_obj->{results} = $resolver->bgread($query_obj->{socket});
		    $query_obj->{waiting}-- if $query_obj->{waiting};
		    if ($query_obj->{waiting} <= 0) {
			 delete $dns_queries{$query};
		    }
		    if (not defined $query_obj->{results}) {
			 warn "Failure to read results for query '$query'";
			 return undef;
		    }
		    return $query_obj->{results};
	       }
	       elsif ($param{noblock}) {
		    return 1;
	       }
	       else {
		    warn "Socket timed out without dns results for '$query'";
		    $query_obj->{waiting}-- if $query_obj->{waiting};
		    if ($query_obj->{waiting} <= 0) {
			 undef $query_obj;
			 delete $dns_queries{$query};
		    }
		    return undef;
	       }
	  }
	  else {
	       warn "Socket disapeared without dns results for '$query'";
	       undef $query_obj;
	       delete $dns_queries{$query};
	       return undef;
	  }
     }
     return $query_obj->{results};
}

sub dns_rbl {
     my %param = validate_with(params => \@_,
			       spec => {dns => SCALAR,
					attr => SCALAR,
					dyn  => {type => SCALAR,
						 default => 0,
						},
					variables => HASHREF,
					test_results => HASHREF,
					noblock      => {type => BOOLEAN,
							 default => 0,
							},
				       },
			      );

     my $query = $param{variables}{$param{attr}};
     # fix up attributes for the query
     if ($param{attr} ne 'sender') {
	  $query = reverse_ips($query);
     }
     warn "Query not defined during test of $param{dns}" and return undef;
     $query = "${query}.$param{dns}";
     my $results = resolve_dns(query => $query,
			       noblock  => $param{noblock},
			      );
     if ($param{noblock} and not defined $results or
	 not ref $results) {
	  return ($results,1);
     }
     if (not defined $results) {
	  warn "Query of '$query' for dns '$param{dns}' failed";
	  return undef;
     }
     for my $record ($results->answer) {
	  next unless $record->type eq 'A';
	  return BAD;
     }
     return GOOD;
}

sub test_helo_reverse {
     my %param = validate_with(params => \@_,
			       spec => {variables => HASHREF,
					test_results => HASHREF,
					noblock         => {type => BOOLEAN,
							 default => 0,
							},
				       },
			      );

     my $helostring	= $param{variables}{helo_name};
     my $clientaddress	= $param{variables}{client_address};

     if ($helostring eq $clientaddress) {
	  # Great, the client told us his correct name!
	  return GOOD;
     } else {
	  # That didn't match. Let's see.
	  # try if the helo names resolves, and has perhaps more than one dns
	  # record....
	  my $results = resolve_dns(query => $helostring,
				    noblock  => $param{noblock},
				   );
	  if ($param{noblock} and not defined $results or
	      not ref $results) {
	       return ($results,1);
	  }
	  if (first { $_->string() eq $clientaddress } $results->answer()) {
	       return GOOD;
	  }
     }
     # For now, just give "bad" score.
     return BAD;
}

sub test_helo_numeric {
     my %param = validate_with(params => \@_,
			       spec => {variables => HASHREF,
					test_results => HASHREF,
					noblock         => {type => BOOLEAN,
							 default => 0,
							},
				       },
			      );

    my $helostring = $param{variables}{helo_name};
    if($helostring =~ /\d$/) {
	return GOOD;
    } else {
	return BAD;
    }
}

sub test_helo_seems_dialup {
     my %param = validate_with(params => \@_,
			       spec => {variables => HASHREF,
					test_results => HASHREF,
					noblock         => {type => BOOLEAN,
							 default => 0,
							},
				       },
			      );

    my $helostring = $param{variables}{helo_name};
    if (($helostring =~
	    /(\.dip\.|cable|ppp|dial|dsl|dyn|client|rev.*?(ip|home)*).*?\..*?\./i
	) || ($helostring =~
	    /[a-z\.\-\_]+\d{1,3}[-._]\d{1,3}[-._]\d{1,3}[-._]\d{1,3}/i
	)) {
	# our client at least behaves correctly, we get a dialup pattern as helo string
	return BAD;
    }
    return GOOD;
}

sub test_sender_anonymous {
     my %param = validate_with(params => \@_,
			       spec => {variables => HASHREF,
					test_results => HASHREF,
					noblock         => {type => BOOLEAN,
							 default => 0,
							},
				       },
			      );


    # Does our mail comes from a potential daemon?
    my $sender  = $param{variables}{sender};
    if ($sender =~ /(nobody|apache|nonymous|www[run|\-data])\@/) {
	return BAD;
    }
    return GOOD;
}

sub test_sender_spf {
     my %param = validate_with(params => \@_,
			       spec => {variables => HASHREF,
					test_results => HASHREF,
					noblock         => {type => BOOLEAN,
							 default => 0,
							},
				       },
			      );
    # Does our mail comes from a domain using SPF?
    # only spammers use SPF
    # <maxx> SPF = Spammer Point-out Framework
    my $sender  = $param{variables}{sender};
    if ($sender =~ /(.*)\@(.*)/) {
	my $domain = $2;
	my $results = resolve_dns(query => $domain,
				  noblock  => $param{noblock},
				 );
	if ($param{noblock} and not defined $results or
	    not ref $results) {
	     return ($results,1);
	}
	if (first {$_->string =~ /v=spf/} $results->answer()) {
	    return BAD;
	}
    }
    return GOOD;
}

sub test_sender_vs_helo($$) {
     my %param = validate_with(params => \@_,
			       spec => {variables => HASHREF,
					test_results => HASHREF,
					noblock         => {type => BOOLEAN,
							 default => 0,
							},
				       },
			      );
    # does the senders domain matches the helo string
    my $sender = $param{variables}{sender};
    my $helostring = $param{variables}{helo_name};

    if ($sender =~  /(.*)\@(.*)/) {
	my $domain = $2;
	if ($domain && $helostring =~ /$domain/) {
	    return BAD;
	} else {
	    return GOOD;
	}
    }
}


# read from database if we already have a value pair in the database
# we assume netblock size of /24 being the same sender.
sub read_database($) {
    my $attr = shift();
    my $timestamp = time();
    
    my $key = md5(subnet_ips($attr->{client_address})."/".$attr->{sender}."/".$attr->{recipient});

    # get the time of last try
    my $lasttime = $db{$key} if (defined($db{$key}));

    if(defined($lasttime)){
	# we have a last try in the database
	if ($timestamp >= $lasttime+$delaytime) {
	    # is the last try long enough ago?
	    return 1;
	} else {
	    return 0;
	}
    } else {
	# he was never here before
	return undef; # XXX EVIL EVIL EVIL XXX FIXME FIXME TODO

    }
}

# write to database the our information and the timestamp
# we asume netblock size of /24 being the same sender.
sub write_database($) {
    my $attr = shift();
    my $timestamp = time();

    my $key = md5(subnet_ips($attr->{client_address})."/".$attr->{sender}."/".$attr->{recipient});

    $db{$key} = $timestamp;
}

sub handle_message{
     my ($variables,$socket) = @_;
     # look up entry in database
     # if an entry for the host exists and has 250s, accept

     # if an entry for the host exists but does not have 250s
     # check to see if the from/to pair exists for (any) host
     # if the hosts do not match
     ## 250, mark both as 250'd; flag for review (possible keep)

     # no host entry, no matching from/to pair
     # figure out if we should greylist


     # add host entry and from/to pair with decision

     # announce decision
}

# sub parse_input($) {
#     my $attr = shift();
#     my $response;
#     my $score=0;
# 
#     if (defined(read_database($attr))) {
# 	$response = read_database($attr);
# 	if ($response) {
# 	    return "dunno";
# 	} else {
# 	    return "defer_if_permit Service temporarily unavailable";
# 	}
#     } else {
# 	# Test: Is client's IP listed in some RBL lists?
# 	$score = $score + test_rbldns($attr->{client_address});
# 
# 	# Test: Is sender listed in some RH RBL lists?
# 	$score = $score + test_rhrbldns($attr->{sender});
# 
# 	# Test: is HELO numeric?
# 	if (test_helo_numeric($attr->{helo_name})) {
# 	    $score = $score + $helo_numeric_score[BAD]; 
# 	} else {
# 	    # Test: Reverse IP == HELO check?
# 	    $score = $score + test_helo_reverse($attr->{helo_name}, $attr->{reverse_client_name});
# 	}
# 
# 	if ($client_seems_dialup == 1) {
# 	    $score = $score + test_helo_seems_dialup($attr->{helo_name});
# 	}
# 
# 	# Test: is our mail coming from a potential daemon?
# 	$score = $score + test_sender_anonymous($attr->{sender});
# 
# 	# Test: is our mail coming from a domain with SPF records?
# 	$score = $score + test_sender_spf($attr->{sender});
# 
# 	if ($score > $cutoff) {
# 	    write_database($attr);
# 	    return "defer_if_permit Service temporarily unavailable";
# 	} else {
# 	    return "PREPEND X-Greylisting: score is $score";
# 	}
# 
#     }
# 
#     # no strict 'refs';
#     # $response = weighted_check->(attr=>\%attr);
# }

$SIG{INT} = \&cleanup;


sub main {
     # Create the sockets
     my @sockets;
     # handle unix sockets
     for my $socket_file (@{$options{socket}}) {
	  my $socket =
	       IO::Socket::UNIX->new(#Type => SOCK_STREAM,
				     Local => $socket_file,
				     Listen => 1,
				    )
			 or die "Unable to create socket for $socket_file";
	  push @sockets,$socket;
     }
     for my $socket_host (@{$options{host}}) {
	  # figure out hostname/port
	  my ($host,$port) = $socket_host =~ /(.+)\:(\d+)$/;
	  if (not defined $host or not defined $port) {
	       die "Socket host $socket_host not foohost:23 format";
	  }
	  my $socket =
	       IO::Socket::INET->new(Proto       => 'tcp',
				     LocalHost   => $host,
				     LocalPort   => $port,
				     Listen      => $options{max_connections},
				     Reuse       => 1)
			 or die "master: bind $tcp_port: $@ $!";
	  push @sockets,$socket;
     }
     my %attr;
     # FIXME: catch TCPSocketInUseExeption e
     my $read_set = IO::Select->new() or
	  die "Unable to create IO::Select";
     $read_set->add(@sockets);
     my %listen_sockets;
     # keep track of which sockets are listen sockets
     @listen_sockets{@sockets} = (1) x @sockets;
     # end FIXME
     #
     my %request_sockets;
     # FIXME: endless loop... grrr
     my @reads;
     # get a set of readable handles (blocks until at least one handle is ready)
     while (@reads = $read_set->can_read()) {
	# take all readable handles in turn
	foreach my $rh (@reads) {
	    # if it is the main socket then we have an incoming connection and
	     # we should accept() it and then add the new socket to the $read_set
	    if ($listen_sockets{$rh}) {
		my $ns = $rh->accept();
		$read_set->add($ns);
		$request_sockets{$ns} = {};
	    } else {
		# otherwise it is an ordinary socket and we should read and process the request
		my $buf = <$rh>;
		if($buf) { # we get normal input
		    if ( $buf =~ /^\s*$/ ) {
			# we get a newline, no more information will come from
			# postfix for this mail
			# postfix now waits for my answer
			if ($request_sockets{$rh}{variables}) {
			    if ($options{verbose}) {
				 while (my ($key,$value) =
					each %{$request_sockets{$rh}{variables}}
				       ) {
				      syslog $syslog_priority, "Key: %s, Value: %s", $key,$value;
				 }
			    }
			    #my $action = parse_input(\%attr);
			    my $action = "PREPEND X-Greylisting: disabled";
			    print STDERR "Handled $action\n";
			    $rh->send("action=".$action."\r\n");
			    $rh->send("\r\n");
			    delete $request_sockets{$rh}{variables};
		        }
		    } elsif ( $buf =~ /([^=]+)=(.*)\r\n/ ) {
			# we get valid input from postfix
			$request_sockets{$rh}{variables}{substr($1, 0, 512)} = substr($2, 0, 512);
		    } else {
			syslog $syslog_priority, "warning: ignoring garbage: %.100s", $buf;
		    }
		} else { # the client has closed the socket
		    # remove the socket from the $read_set and close it 
		    $read_set->remove($rh);
		    close($rh);
		}
	    }
	}
    }
}

main();

sub cleanup {
     print STDERR "got sig int\n";
     exit 0;
}

END {
     for my $socket_file (@{$options{socket}}) {
	  print STDERR "unlinking $socket_file\n";
	  unlink($socket_file) if -e $socket_file;
     }
}

__END__
